home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tcl7.4 / tclCmdMZ.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-04-30  |  46.7 KB  |  1,921 lines
  1. /* 
  2.  * tclCmdMZ.c --
  3.  *
  4.  *    This file contains the top-level command routines for most of
  5.  *    the Tcl built-in commands whose names begin with the letters
  6.  *    M to Z.  It contains only commands in the generic core (i.e.
  7.  *    those that don't depend much upon UNIX facilities).
  8.  *
  9.  * Copyright (c) 1987-1993 The Regents of the University of California.
  10.  * Copyright (c) 1994-1995 Sun Microsystems, Inc.
  11.  *
  12.  * See the file "license.terms" for information on usage and redistribution
  13.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14.  */
  15.  
  16. #ifndef lint
  17. static char sccsid[] = "@(#) tclCmdMZ.c 1.57 95/04/30 14:35:17";
  18. #endif
  19.  
  20. #include "tclInt.h"
  21. #include "tclPort.h"
  22.  
  23. /*
  24.  * Structure used to hold information about variable traces:
  25.  */
  26.  
  27. typedef struct {
  28.     int flags;            /* Operations for which Tcl command is
  29.                  * to be invoked. */
  30.     char *errMsg;        /* Error message returned from Tcl command,
  31.                  * or NULL.  Malloc'ed. */
  32.     int length;            /* Number of non-NULL chars. in command. */
  33.     char command[4];        /* Space for Tcl command to invoke.  Actual
  34.                  * size will be as large as necessary to
  35.                  * hold command.  This field must be the
  36.                  * last in the structure, so that it can
  37.                  * be larger than 4 bytes. */
  38. } TraceVarInfo;
  39.  
  40. /*
  41.  * Forward declarations for procedures defined in this file:
  42.  */
  43.  
  44. static char *        TraceVarProc _ANSI_ARGS_((ClientData clientData,
  45.                 Tcl_Interp *interp, char *name1, char *name2,
  46.                 int flags));
  47.  
  48. /*
  49.  *----------------------------------------------------------------------
  50.  *
  51.  * Tcl_RegexpCmd --
  52.  *
  53.  *    This procedure is invoked to process the "regexp" Tcl command.
  54.  *    See the user documentation for details on what it does.
  55.  *
  56.  * Results:
  57.  *    A standard Tcl result.
  58.  *
  59.  * Side effects:
  60.  *    See the user documentation.
  61.  *
  62.  *----------------------------------------------------------------------
  63.  */
  64.  
  65.     /* ARGSUSED */
  66. int
  67. Tcl_RegexpCmd(dummy, interp, argc, argv)
  68.     ClientData dummy;            /* Not used. */
  69.     Tcl_Interp *interp;            /* Current interpreter. */
  70.     int argc;                /* Number of arguments. */
  71.     char **argv;            /* Argument strings. */
  72. {
  73.     int noCase = 0;
  74.     int indices = 0;
  75.     Tcl_RegExp regExpr;
  76.     char **argPtr, *string, *pattern, *start, *end;
  77.     int match = 0;            /* Initialization needed only to
  78.                      * prevent compiler warning. */
  79.     int i;
  80.     Tcl_DString stringDString, patternDString;
  81.  
  82.     if (argc < 3) {
  83.     wrongNumArgs:
  84.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  85.         " ?switches? exp string ?matchVar? ?subMatchVar ",
  86.         "subMatchVar ...?\"", (char *) NULL);
  87.     return TCL_ERROR;
  88.     }
  89.     argPtr = argv+1;
  90.     argc--;
  91.     while ((argc > 0) && (argPtr[0][0] == '-')) {
  92.     if (strcmp(argPtr[0], "-indices") == 0) {
  93.         indices = 1;
  94.     } else if (strcmp(argPtr[0], "-nocase") == 0) {
  95.         noCase = 1;
  96.     } else if (strcmp(argPtr[0], "--") == 0) {
  97.         argPtr++;
  98.         argc--;
  99.         break;
  100.     } else {
  101.         Tcl_AppendResult(interp, "bad switch \"", argPtr[0],
  102.             "\": must be -indices, -nocase, or --", (char *) NULL);
  103.         return TCL_ERROR;
  104.     }
  105.     argPtr++;
  106.     argc--;
  107.     }
  108.     if (argc < 2) {
  109.     goto wrongNumArgs;
  110.     }
  111.  
  112.     /*
  113.      * Convert the string and pattern to lower case, if desired, and
  114.      * perform the matching operation.
  115.      */
  116.  
  117.     if (noCase) {
  118.     register char *p;
  119.  
  120.     Tcl_DStringInit(&patternDString);
  121.     Tcl_DStringAppend(&patternDString, argPtr[0], -1);
  122.     pattern = Tcl_DStringValue(&patternDString);
  123.     for (p = pattern; *p != 0; p++) {
  124.         if (isupper(UCHAR(*p))) {
  125.         *p = tolower(*p);
  126.         }
  127.     }
  128.     Tcl_DStringInit(&stringDString);
  129.     Tcl_DStringAppend(&stringDString, argPtr[1], -1);
  130.     string = Tcl_DStringValue(&stringDString);
  131.     for (p = string; *p != 0; p++) {
  132.         if (isupper(UCHAR(*p))) {
  133.         *p = tolower(*p);
  134.         }
  135.     }
  136.     } else {
  137.     pattern = argPtr[0];
  138.     string = argPtr[1];
  139.     }
  140.     regExpr = Tcl_RegExpCompile(interp, pattern);
  141.     if (regExpr != NULL) {
  142.     match = Tcl_RegExpExec(interp, regExpr, string, string);
  143.     }
  144.     if (noCase) {
  145.     Tcl_DStringFree(&stringDString);
  146.     Tcl_DStringFree(&patternDString);
  147.     }
  148.     if (regExpr == NULL) {
  149.     return TCL_ERROR;
  150.     }
  151.     if (match < 0) {
  152.     return TCL_ERROR;
  153.     }
  154.     if (!match) {
  155.     interp->result = "0";
  156.     return TCL_OK;
  157.     }
  158.  
  159.     /*
  160.      * If additional variable names have been specified, return
  161.      * index information in those variables.
  162.      */
  163.  
  164.     argc -= 2;
  165.     for (i = 0; i < argc; i++) {
  166.     char *result, info[50];
  167.  
  168.     Tcl_RegExpRange(regExpr, i, &start, &end);
  169.     if (start == NULL) {
  170.         if (indices) {
  171.         result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0);
  172.         } else {
  173.         result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
  174.         }
  175.     } else {
  176.         if (indices) {
  177.         sprintf(info, "%d %d", start - string,
  178.             end - string - 1);
  179.         result = Tcl_SetVar(interp, argPtr[i+2], info, 0);
  180.         } else {
  181.         char savedChar, *first, *last;
  182.  
  183.         first = argPtr[1] + (start - string);
  184.         last = argPtr[1] + (end - string);
  185.         savedChar = *last;
  186.         *last = 0;
  187.         result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
  188.         *last = savedChar;
  189.         }
  190.     }
  191.     if (result == NULL) {
  192.         Tcl_AppendResult(interp, "couldn't set variable \"",
  193.             argPtr[i+2], "\"", (char *) NULL);
  194.         return TCL_ERROR;
  195.     }
  196.     }
  197.     interp->result = "1";
  198.     return TCL_OK;
  199. }
  200.  
  201. /*
  202.  *----------------------------------------------------------------------
  203.  *
  204.  * Tcl_RegsubCmd --
  205.  *
  206.  *    This procedure is invoked to process the "regsub" Tcl command.
  207.  *    See the user documentation for details on what it does.
  208.  *
  209.  * Results:
  210.  *    A standard Tcl result.
  211.  *
  212.  * Side effects:
  213.  *    See the user documentation.
  214.  *
  215.  *----------------------------------------------------------------------
  216.  */
  217.  
  218.     /* ARGSUSED */
  219. int
  220. Tcl_RegsubCmd(dummy, interp, argc, argv)
  221.     ClientData dummy;            /* Not used. */
  222.     Tcl_Interp *interp;            /* Current interpreter. */
  223.     int argc;                /* Number of arguments. */
  224.     char **argv;            /* Argument strings. */
  225. {
  226.     int noCase = 0, all = 0;
  227.     Tcl_RegExp regExpr;
  228.     char *string, *pattern, *p, *firstChar, *newValue, **argPtr;
  229.     int match, flags, code, numMatches;
  230.     char *start, *end, *subStart, *subEnd;
  231.     register char *src, c;
  232.     Tcl_DString stringDString, patternDString;
  233.  
  234.     if (argc < 5) {
  235.     wrongNumArgs:
  236.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  237.         " ?switches? exp string subSpec varName\"", (char *) NULL);
  238.     return TCL_ERROR;
  239.     }
  240.     argPtr = argv+1;
  241.     argc--;
  242.     while (argPtr[0][0] == '-') {
  243.     if (strcmp(argPtr[0], "-nocase") == 0) {
  244.         noCase = 1;
  245.     } else if (strcmp(argPtr[0], "-all") == 0) {
  246.         all = 1;
  247.     } else if (strcmp(argPtr[0], "--") == 0) {
  248.         argPtr++;
  249.         argc--;
  250.         break;
  251.     } else {
  252.         Tcl_AppendResult(interp, "bad switch \"", argPtr[0],
  253.             "\": must be -all, -nocase, or --", (char *) NULL);
  254.         return TCL_ERROR;
  255.     }
  256.     argPtr++;
  257.     argc--;
  258.     }
  259.     if (argc != 4) {
  260.     goto wrongNumArgs;
  261.     }
  262.  
  263.     /*
  264.      * Convert the string and pattern to lower case, if desired.
  265.      */
  266.  
  267.     if (noCase) {
  268.     Tcl_DStringInit(&patternDString);
  269.     Tcl_DStringAppend(&patternDString, argPtr[0], -1);
  270.     pattern = Tcl_DStringValue(&patternDString);
  271.     for (p = pattern; *p != 0; p++) {
  272.         if (isupper(UCHAR(*p))) {
  273.         *p = tolower(*p);
  274.         }
  275.     }
  276.     Tcl_DStringInit(&stringDString);
  277.     Tcl_DStringAppend(&stringDString, argPtr[1], -1);
  278.     string = Tcl_DStringValue(&stringDString);
  279.     for (p = string; *p != 0; p++) {
  280.         if (isupper(UCHAR(*p))) {
  281.         *p = tolower(*p);
  282.         }
  283.     }
  284.     } else {
  285.     pattern = argPtr[0];
  286.     string = argPtr[1];
  287.     }
  288.     regExpr = Tcl_RegExpCompile(interp, pattern);
  289.     if (regExpr == NULL) {
  290.     code = TCL_ERROR;
  291.     goto done;
  292.     }
  293.  
  294.     /*
  295.      * The following loop is to handle multiple matches within the
  296.      * same source string;  each iteration handles one match and its
  297.      * corresponding substitution.  If "-all" hasn't been specified
  298.      * then the loop body only gets executed once.
  299.      */
  300.  
  301.     flags = 0;
  302.     numMatches = 0;
  303.     for (p = string; *p != 0; ) {
  304.     match = Tcl_RegExpExec(interp, regExpr, p, string);
  305.     if (match < 0) {
  306.         code = TCL_ERROR;
  307.         goto done;
  308.     }
  309.     if (!match) {
  310.         break;
  311.     }
  312.     numMatches += 1;
  313.  
  314.     /*
  315.      * Copy the portion of the source string before the match to the
  316.      * result variable.
  317.      */
  318.  
  319.     Tcl_RegExpRange(regExpr, 0, &start, &end);
  320.     src = argPtr[1] + (start - string);
  321.     c = *src;
  322.     *src = 0;
  323.     newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string),
  324.         flags);
  325.     *src = c;
  326.     flags = TCL_APPEND_VALUE;
  327.     if (newValue == NULL) {
  328.         cantSet:
  329.         Tcl_AppendResult(interp, "couldn't set variable \"",
  330.             argPtr[3], "\"", (char *) NULL);
  331.         code = TCL_ERROR;
  332.         goto done;
  333.     }
  334.     
  335.     /*
  336.      * Append the subSpec argument to the variable, making appropriate
  337.      * substitutions.  This code is a bit hairy because of the backslash
  338.      * conventions and because the code saves up ranges of characters in
  339.      * subSpec to reduce the number of calls to Tcl_SetVar.
  340.      */
  341.     
  342.     for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) {
  343.         int index;
  344.     
  345.         if (c == '&') {
  346.         index = 0;
  347.         } else if (c == '\\') {
  348.         c = src[1];
  349.         if ((c >= '0') && (c <= '9')) {
  350.             index = c - '0';
  351.         } else if ((c == '\\') || (c == '&')) {
  352.             *src = c;
  353.             src[1] = 0;
  354.             newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
  355.                 TCL_APPEND_VALUE);
  356.             *src = '\\';
  357.             src[1] = c;
  358.             if (newValue == NULL) {
  359.             goto cantSet;
  360.             }
  361.             firstChar = src+2;
  362.             src++;
  363.             continue;
  364.         } else {
  365.             continue;
  366.         }
  367.         } else {
  368.         continue;
  369.         }
  370.         if (firstChar != src) {
  371.         c = *src;
  372.         *src = 0;
  373.         newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
  374.             TCL_APPEND_VALUE);
  375.         *src = c;
  376.         if (newValue == NULL) {
  377.             goto cantSet;
  378.         }
  379.         }
  380.         Tcl_RegExpRange(regExpr, index, &subStart, &subEnd);
  381.         if ((subStart != NULL) && (subEnd != NULL)) {
  382.         char *first, *last, saved;
  383.     
  384.         first = argPtr[1] + (subStart - string);
  385.         last = argPtr[1] + (subEnd - string);
  386.         saved = *last;
  387.         *last = 0;
  388.         newValue = Tcl_SetVar(interp, argPtr[3], first,
  389.             TCL_APPEND_VALUE);
  390.         *last = saved;
  391.         if (newValue == NULL) {
  392.             goto cantSet;
  393.         }
  394.         }
  395.         if (*src == '\\') {
  396.         src++;
  397.         }
  398.         firstChar = src+1;
  399.     }
  400.     if (firstChar != src) {
  401.         if (Tcl_SetVar(interp, argPtr[3], firstChar,
  402.             TCL_APPEND_VALUE) == NULL) {
  403.         goto cantSet;
  404.         }
  405.     }
  406.     if (end == p) {
  407.         char tmp[2];
  408.  
  409.         /*
  410.          * Always consume at least one character of the input string
  411.          * in order to prevent infinite loops.
  412.          */
  413.  
  414.         tmp[0] = argPtr[1][p - string];
  415.         tmp[1] = 0;
  416.         newValue = Tcl_SetVar(interp, argPtr[3], tmp, flags);
  417.         if (newValue == NULL) {
  418.         goto cantSet;
  419.         }
  420.         p = end + 1;
  421.     } else {
  422.         p = end;
  423.     }
  424.     if (!all) {
  425.         break;
  426.     }
  427.     }
  428.  
  429.     /*
  430.      * Copy the portion of the source string after the last match to the
  431.      * result variable.
  432.      */
  433.  
  434.     if ((*p != 0) || (numMatches == 0)) {
  435.     if (Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string), 
  436.         flags) == NULL) {
  437.         goto cantSet;
  438.     }
  439.     }
  440.     sprintf(interp->result, "%d", numMatches);
  441.     code = TCL_OK;
  442.  
  443.     done:
  444.     if (noCase) {
  445.     Tcl_DStringFree(&stringDString);
  446.     Tcl_DStringFree(&patternDString);
  447.     }
  448.     return code;
  449. }
  450.  
  451. /*
  452.  *----------------------------------------------------------------------
  453.  *
  454.  * Tcl_RenameCmd --
  455.  *
  456.  *    This procedure is invoked to process the "rename" Tcl command.
  457.  *    See the user documentation for details on what it does.
  458.  *
  459.  * Results:
  460.  *    A standard Tcl result.
  461.  *
  462.  * Side effects:
  463.  *    See the user documentation.
  464.  *
  465.  *----------------------------------------------------------------------
  466.  */
  467.  
  468.     /* ARGSUSED */
  469. int
  470. Tcl_RenameCmd(dummy, interp, argc, argv)
  471.     ClientData dummy;            /* Not used. */
  472.     Tcl_Interp *interp;            /* Current interpreter. */
  473.     int argc;                /* Number of arguments. */
  474.     char **argv;            /* Argument strings. */
  475. {
  476.     register Command *cmdPtr;
  477.     Interp *iPtr = (Interp *) interp;
  478.     Tcl_HashEntry *hPtr;
  479.     int new;
  480.  
  481.     if (argc != 3) {
  482.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  483.         " oldName newName\"", (char *) NULL);
  484.     return TCL_ERROR;
  485.     }
  486.     if (argv[2][0] == '\0') {
  487.     if (Tcl_DeleteCommand(interp, argv[1]) != 0) {
  488.         Tcl_AppendResult(interp, "can't delete \"", argv[1],
  489.             "\": command doesn't exist", (char *) NULL);
  490.         return TCL_ERROR;
  491.     }
  492.     return TCL_OK;
  493.     }
  494.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[2]);
  495.     if (hPtr != NULL) {
  496.     Tcl_AppendResult(interp, "can't rename to \"", argv[2],
  497.         "\": command already exists", (char *) NULL);
  498.     return TCL_ERROR;
  499.     }
  500.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[1]);
  501.     if (hPtr == NULL) {
  502.     Tcl_AppendResult(interp, "can't rename \"", argv[1],
  503.         "\":  command doesn't exist", (char *) NULL);
  504.     return TCL_ERROR;
  505.     }
  506.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  507.     Tcl_DeleteHashEntry(hPtr);
  508.     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, argv[2], &new);
  509.     Tcl_SetHashValue(hPtr, cmdPtr);
  510.     cmdPtr->hPtr = hPtr;
  511.     return TCL_OK;
  512. }
  513.  
  514. /*
  515.  *----------------------------------------------------------------------
  516.  *
  517.  * Tcl_ReturnCmd --
  518.  *
  519.  *    This procedure is invoked to process the "return" Tcl command.
  520.  *    See the user documentation for details on what it does.
  521.  *
  522.  * Results:
  523.  *    A standard Tcl result.
  524.  *
  525.  * Side effects:
  526.  *    See the user documentation.
  527.  *
  528.  *----------------------------------------------------------------------
  529.  */
  530.  
  531.     /* ARGSUSED */
  532. int
  533. Tcl_ReturnCmd(dummy, interp, argc, argv)
  534.     ClientData dummy;            /* Not used. */
  535.     Tcl_Interp *interp;            /* Current interpreter. */
  536.     int argc;                /* Number of arguments. */
  537.     char **argv;            /* Argument strings. */
  538. {
  539.     Interp *iPtr = (Interp *) interp;
  540.     int c, code;
  541.  
  542.     if (iPtr->errorInfo != NULL) {
  543.     ckfree(iPtr->errorInfo);
  544.     iPtr->errorInfo = NULL;
  545.     }
  546.     if (iPtr->errorCode != NULL) {
  547.     ckfree(iPtr->errorCode);
  548.     iPtr->errorCode = NULL;
  549.     }
  550.     code = TCL_OK;
  551.     for (argv++, argc--; argc > 1; argv += 2, argc -= 2) {
  552.     if (strcmp(argv[0], "-code") == 0) {
  553.         c = argv[1][0];
  554.         if ((c == 'o') && (strcmp(argv[1], "ok") == 0)) {
  555.         code = TCL_OK;
  556.         } else if ((c == 'e') && (strcmp(argv[1], "error") == 0)) {
  557.         code = TCL_ERROR;
  558.         } else if ((c == 'r') && (strcmp(argv[1], "return") == 0)) {
  559.         code = TCL_RETURN;
  560.         } else if ((c == 'b') && (strcmp(argv[1], "break") == 0)) {
  561.         code = TCL_BREAK;
  562.         } else if ((c == 'c') && (strcmp(argv[1], "continue") == 0)) {
  563.         code = TCL_CONTINUE;
  564.         } else if (Tcl_GetInt(interp, argv[1], &code) != TCL_OK) {
  565.         Tcl_ResetResult(interp);
  566.         Tcl_AppendResult(interp, "bad completion code \"",
  567.             argv[1], "\": must be ok, error, return, break, ",
  568.             "continue, or an integer", (char *) NULL);
  569.         return TCL_ERROR;
  570.         }
  571.     } else if (strcmp(argv[0], "-errorinfo") == 0) {
  572.         iPtr->errorInfo = ckalloc((unsigned) (strlen(argv[1]) + 1));
  573.         strcpy(iPtr->errorInfo, argv[1]);
  574.     } else if (strcmp(argv[0], "-errorcode") == 0) {
  575.         iPtr->errorCode = ckalloc((unsigned) (strlen(argv[1]) + 1));
  576.         strcpy(iPtr->errorCode, argv[1]);
  577.     } else {
  578.         Tcl_AppendResult(interp, "bad option \"", argv[0],
  579.             ": must be -code, -errorcode, or -errorinfo",
  580.             (char *) NULL);
  581.         return TCL_ERROR;
  582.     }
  583.     }
  584.     if (argc == 1) {
  585.     Tcl_SetResult(interp, argv[0], TCL_VOLATILE);
  586.     }
  587.     iPtr->returnCode = code;
  588.     return TCL_RETURN;
  589. }
  590.  
  591. /*
  592.  *----------------------------------------------------------------------
  593.  *
  594.  * Tcl_ScanCmd --
  595.  *
  596.  *    This procedure is invoked to process the "scan" Tcl command.
  597.  *    See the user documentation for details on what it does.
  598.  *
  599.  * Results:
  600.  *    A standard Tcl result.
  601.  *
  602.  * Side effects:
  603.  *    See the user documentation.
  604.  *
  605.  *----------------------------------------------------------------------
  606.  */
  607.  
  608.     /* ARGSUSED */
  609. int
  610. Tcl_ScanCmd(dummy, interp, argc, argv)
  611.     ClientData dummy;            /* Not used. */
  612.     Tcl_Interp *interp;            /* Current interpreter. */
  613.     int argc;                /* Number of arguments. */
  614.     char **argv;            /* Argument strings. */
  615. {
  616. #   define MAX_FIELDS 20
  617.     typedef struct {
  618.     char fmt;            /* Format for field. */
  619.     int size;            /* How many bytes to allow for
  620.                      * field. */
  621.     char *location;            /* Where field will be stored. */
  622.     } Field;
  623.     Field fields[MAX_FIELDS];        /* Info about all the fields in the
  624.                      * format string. */
  625.     register Field *curField;
  626.     int numFields = 0;            /* Number of fields actually
  627.                      * specified. */
  628.     int suppress;            /* Current field is assignment-
  629.                      * suppressed. */
  630.     int totalSize = 0;            /* Number of bytes needed to store
  631.                      * all results combined. */
  632.     char *results;            /* Where scanned output goes.
  633.                      * Malloced; NULL means not allocated
  634.                      * yet. */
  635.     int numScanned;            /* sscanf's result. */
  636.     register char *fmt;
  637.     int i, widthSpecified, length, code;
  638.  
  639.     /*
  640.      * The variables below are used to hold a copy of the format
  641.      * string, so that we can replace format specifiers like "%f"
  642.      * and "%F" with specifiers like "%lf"
  643.      */
  644.  
  645. #   define STATIC_SIZE 5
  646.     char copyBuf[STATIC_SIZE], *fmtCopy;
  647.     register char *dst;
  648.  
  649.     if (argc < 3) {
  650.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  651.         " string format ?varName varName ...?\"", (char *) NULL);
  652.     return TCL_ERROR;
  653.     }
  654.  
  655.     /*
  656.      * This procedure operates in four stages:
  657.      * 1. Scan the format string, collecting information about each field.
  658.      * 2. Allocate an array to hold all of the scanned fields.
  659.      * 3. Call sscanf to do all the dirty work, and have it store the
  660.      *    parsed fields in the array.
  661.      * 4. Pick off the fields from the array and assign them to variables.
  662.      */
  663.  
  664.     code = TCL_OK;
  665.     results = NULL;
  666.     length = strlen(argv[2]) * 2 + 1;
  667.     if (length < STATIC_SIZE) {
  668.     fmtCopy = copyBuf;
  669.     } else {
  670.     fmtCopy = ckalloc((unsigned) length);
  671.     }
  672.     dst = fmtCopy;
  673.     for (fmt = argv[2]; *fmt != 0; fmt++) {
  674.     *dst = *fmt;
  675.     dst++;
  676.     if (*fmt != '%') {
  677.         continue;
  678.     }
  679.     fmt++;
  680.     if (*fmt == '%') {
  681.         *dst = *fmt;
  682.         dst++;
  683.         continue;
  684.     }
  685.     if (*fmt == '*') {
  686.         suppress = 1;
  687.         *dst = *fmt;
  688.         dst++;
  689.         fmt++;
  690.     } else {
  691.         suppress = 0;
  692.     }
  693.     widthSpecified = 0;
  694.     while (isdigit(UCHAR(*fmt))) {
  695.         widthSpecified = 1;
  696.         *dst = *fmt;
  697.         dst++;
  698.         fmt++;
  699.     }
  700.     if ((*fmt == 'l') || (*fmt == 'h') || (*fmt == 'L')) {
  701.         fmt++;
  702.     }
  703.     *dst = *fmt;
  704.     dst++;
  705.     if (suppress) {
  706.         continue;
  707.     }
  708.     if (numFields == MAX_FIELDS) {
  709.         interp->result = "too many fields to scan";
  710.         code = TCL_ERROR;
  711.         goto done;
  712.     }
  713.     curField = &fields[numFields];
  714.     numFields++;
  715.     switch (*fmt) {
  716.         case 'd':
  717.         case 'i':
  718.         case 'o':
  719.         case 'x':
  720.         curField->fmt = 'd';
  721.         curField->size = sizeof(int);
  722.         break;
  723.  
  724.         case 'u':
  725.         curField->fmt = 'u';
  726.         curField->size = sizeof(int);
  727.         break;
  728.  
  729.         case 's':
  730.         curField->fmt = 's';
  731.         curField->size = strlen(argv[1]) + 1;
  732.         break;
  733.  
  734.         case 'c':
  735.                 if (widthSpecified) {
  736.                     interp->result = 
  737.                          "field width may not be specified in %c conversion";
  738.             code = TCL_ERROR;
  739.             goto done;
  740.                 }
  741.         curField->fmt = 'c';
  742.         curField->size = sizeof(int);
  743.         break;
  744.  
  745.         case 'e':
  746.         case 'f':
  747.         case 'g':
  748.         dst[-1] = 'l';
  749.         dst[0] = 'f';
  750.         dst++;
  751.         curField->fmt = 'f';
  752.         curField->size = sizeof(double);
  753.         break;
  754.  
  755.         case '[':
  756.         curField->fmt = 's';
  757.         curField->size = strlen(argv[1]) + 1;
  758.         do {
  759.             fmt++;
  760.             if (*fmt == 0) {
  761.             interp->result = "unmatched [ in format string";
  762.             code = TCL_ERROR;
  763.             goto done;
  764.             }
  765.             *dst = *fmt;
  766.             dst++;
  767.         } while (*fmt != ']');
  768.         break;
  769.  
  770.         default:
  771.         sprintf(interp->result, "bad scan conversion character \"%c\"",
  772.             *fmt);
  773.         code = TCL_ERROR;
  774.         goto done;
  775.     }
  776.     curField->size = TCL_ALIGN(curField->size);
  777.     totalSize += curField->size;
  778.     }
  779.     *dst = 0;
  780.  
  781.     if (numFields != (argc-3)) {
  782.     interp->result =
  783.         "different numbers of variable names and field specifiers";
  784.     code = TCL_ERROR;
  785.     goto done;
  786.     }
  787.  
  788.     /*
  789.      * Step 2:
  790.      */
  791.  
  792.     results = (char *) ckalloc((unsigned) totalSize);
  793.     for (i = 0, totalSize = 0, curField = fields;
  794.         i < numFields; i++, curField++) {
  795.     curField->location = results + totalSize;
  796.     totalSize += curField->size;
  797.     }
  798.  
  799.     /*
  800.      * Fill in the remaining fields with NULL;  the only purpose of
  801.      * this is to keep some memory analyzers, like Purify, from
  802.      * complaining.
  803.      */
  804.  
  805.     for ( ; i < MAX_FIELDS; i++, curField++) {
  806.     curField->location = NULL;
  807.     }
  808.  
  809.     /*
  810.      * Step 3:
  811.      */
  812.  
  813.     numScanned = sscanf(argv[1], fmtCopy,
  814.         fields[0].location, fields[1].location, fields[2].location,
  815.         fields[3].location, fields[4].location, fields[5].location,
  816.         fields[6].location, fields[7].location, fields[8].location,
  817.         fields[9].location, fields[10].location, fields[11].location,
  818.         fields[12].location, fields[13].location, fields[14].location,
  819.         fields[15].location, fields[16].location, fields[17].location,
  820.         fields[18].location, fields[19].location);
  821.  
  822.     /*
  823.      * Step 4:
  824.      */
  825.  
  826.     if (numScanned < numFields) {
  827.     numFields = numScanned;
  828.     }
  829.     for (i = 0, curField = fields; i < numFields; i++, curField++) {
  830.     switch (curField->fmt) {
  831.         char string[TCL_DOUBLE_SPACE];
  832.  
  833.         case 'd':
  834.         sprintf(string, "%d", *((int *) curField->location));
  835.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  836.             storeError:
  837.             Tcl_AppendResult(interp,
  838.                 "couldn't set variable \"", argv[i+3], "\"",
  839.                 (char *) NULL);
  840.             code = TCL_ERROR;
  841.             goto done;
  842.         }
  843.         break;
  844.  
  845.         case 'u':
  846.         sprintf(string, "%u", *((int *) curField->location));
  847.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  848.             goto storeError;
  849.         }
  850.         break;
  851.  
  852.         case 'c':
  853.         sprintf(string, "%d", *((char *) curField->location) & 0xff);
  854.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  855.             goto storeError;
  856.         }
  857.         break;
  858.  
  859.         case 's':
  860.         if (Tcl_SetVar(interp, argv[i+3], curField->location, 0)
  861.             == NULL) {
  862.             goto storeError;
  863.         }
  864.         break;
  865.  
  866.         case 'f':
  867.         Tcl_PrintDouble(interp, *((double *) curField->location),
  868.             string);
  869.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  870.             goto storeError;
  871.         }
  872.         break;
  873.     }
  874.     }
  875.     sprintf(interp->result, "%d", numScanned);
  876.     done:
  877.     if (results != NULL) {
  878.     ckfree(results);
  879.     }
  880.     if (fmtCopy != copyBuf) {
  881.     ckfree(fmtCopy);
  882.     }
  883.     return code;
  884. }
  885.  
  886. /*
  887.  *----------------------------------------------------------------------
  888.  *
  889.  * Tcl_SplitCmd --
  890.  *
  891.  *    This procedure is invoked to process the "split" Tcl command.
  892.  *    See the user documentation for details on what it does.
  893.  *
  894.  * Results:
  895.  *    A standard Tcl result.
  896.  *
  897.  * Side effects:
  898.  *    See the user documentation.
  899.  *
  900.  *----------------------------------------------------------------------
  901.  */
  902.  
  903.     /* ARGSUSED */
  904. int
  905. Tcl_SplitCmd(dummy, interp, argc, argv)
  906.     ClientData dummy;            /* Not used. */
  907.     Tcl_Interp *interp;            /* Current interpreter. */
  908.     int argc;                /* Number of arguments. */
  909.     char **argv;            /* Argument strings. */
  910. {
  911.     char *splitChars;
  912.     register char *p, *p2;
  913.     char *elementStart;
  914.  
  915.     if (argc == 2) {
  916.     splitChars = " \n\t\r";
  917.     } else if (argc == 3) {
  918.     splitChars = argv[2];
  919.     } else {
  920.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  921.         " string ?splitChars?\"", (char *) NULL);
  922.     return TCL_ERROR;
  923.     }
  924.  
  925.     /*
  926.      * Handle the special case of splitting on every character.
  927.      */
  928.  
  929.     if (*splitChars == 0) {
  930.     char string[2];
  931.     string[1] = 0;
  932.     for (p = argv[1]; *p != 0; p++) {
  933.         string[0] = *p;
  934.         Tcl_AppendElement(interp, string);
  935.     }
  936.     return TCL_OK;
  937.     }
  938.  
  939.     /*
  940.      * Normal case: split on any of a given set of characters.
  941.      * Discard instances of the split characters.
  942.      */
  943.  
  944.     for (p = elementStart = argv[1]; *p != 0; p++) {
  945.     char c = *p;
  946.     for (p2 = splitChars; *p2 != 0; p2++) {
  947.         if (*p2 == c) {
  948.         *p = 0;
  949.         Tcl_AppendElement(interp, elementStart);
  950.         *p = c;
  951.         elementStart = p+1;
  952.         break;
  953.         }
  954.     }
  955.     }
  956.     if (p != argv[1]) {
  957.     Tcl_AppendElement(interp, elementStart);
  958.     }
  959.     return TCL_OK;
  960. }
  961.  
  962. /*
  963.  *----------------------------------------------------------------------
  964.  *
  965.  * Tcl_StringCmd --
  966.  *
  967.  *    This procedure is invoked to process the "string" Tcl command.
  968.  *    See the user documentation for details on what it does.
  969.  *
  970.  * Results:
  971.  *    A standard Tcl result.
  972.  *
  973.  * Side effects:
  974.  *    See the user documentation.
  975.  *
  976.  *----------------------------------------------------------------------
  977.  */
  978.  
  979.     /* ARGSUSED */
  980. int
  981. Tcl_StringCmd(dummy, interp, argc, argv)
  982.     ClientData dummy;            /* Not used. */
  983.     Tcl_Interp *interp;            /* Current interpreter. */
  984.     int argc;                /* Number of arguments. */
  985.     char **argv;            /* Argument strings. */
  986. {
  987.     size_t length;
  988.     register char *p;
  989.     int match, c, first;
  990.     int left = 0, right = 0;
  991.  
  992.     if (argc < 2) {
  993.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  994.         " option arg ?arg ...?\"", (char *) NULL);
  995.     return TCL_ERROR;
  996.     }
  997.     c = argv[1][0];
  998.     length = strlen(argv[1]);
  999.     if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0)) {
  1000.     if (argc != 4) {
  1001.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1002.             " compare string1 string2\"", (char *) NULL);
  1003.         return TCL_ERROR;
  1004.     }
  1005.     match = strcmp(argv[2], argv[3]);
  1006.     if (match > 0) {
  1007.         interp->result = "1";
  1008.     } else if (match < 0) {
  1009.         interp->result = "-1";
  1010.     } else {
  1011.         interp->result = "0";
  1012.     }
  1013.     return TCL_OK;
  1014.     } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) {
  1015.     if (argc != 4) {
  1016.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1017.             " first string1 string2\"", (char *) NULL);
  1018.         return TCL_ERROR;
  1019.     }
  1020.     first = 1;
  1021.  
  1022.     firstLast:
  1023.     match = -1;
  1024.     c = *argv[2];
  1025.     length = strlen(argv[2]);
  1026.     for (p = argv[3]; *p != 0; p++) {
  1027.         if (*p != c) {
  1028.         continue;
  1029.         }
  1030.         if (strncmp(argv[2], p, length) == 0) {
  1031.         match = p-argv[3];
  1032.         if (first) {
  1033.             break;
  1034.         }
  1035.         }
  1036.     }
  1037.     sprintf(interp->result, "%d", match);
  1038.     return TCL_OK;
  1039.     } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) {
  1040.     int index;
  1041.  
  1042.     if (argc != 4) {
  1043.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1044.             " index string charIndex\"", (char *) NULL);
  1045.         return TCL_ERROR;
  1046.     }
  1047.     if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) {
  1048.         return TCL_ERROR;
  1049.     }
  1050.     if ((index >= 0) && (index < (int) strlen(argv[2]))) {
  1051.         interp->result[0] = argv[2][index];
  1052.         interp->result[1] = 0;
  1053.     }
  1054.     return TCL_OK;
  1055.     } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0)
  1056.         && (length >= 2)) {
  1057.     if (argc != 4) {
  1058.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1059.             " last string1 string2\"", (char *) NULL);
  1060.         return TCL_ERROR;
  1061.     }
  1062.     first = 0;
  1063.     goto firstLast;
  1064.     } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0)
  1065.         && (length >= 2)) {
  1066.     if (argc != 3) {
  1067.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1068.             " length string\"", (char *) NULL);
  1069.         return TCL_ERROR;
  1070.     }
  1071.     sprintf(interp->result, "%d", strlen(argv[2]));
  1072.     return TCL_OK;
  1073.     } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) {
  1074.     if (argc != 4) {
  1075.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1076.             " match pattern string\"", (char *) NULL);
  1077.         return TCL_ERROR;
  1078.     }
  1079.     if (Tcl_StringMatch(argv[3], argv[2]) != 0) {
  1080.         interp->result = "1";
  1081.     } else {
  1082.         interp->result = "0";
  1083.     }
  1084.     return TCL_OK;
  1085.     } else if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) {
  1086.     int first, last, stringLength;
  1087.  
  1088.     if (argc != 5) {
  1089.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1090.             " range string first last\"", (char *) NULL);
  1091.         return TCL_ERROR;
  1092.     }
  1093.     stringLength = strlen(argv[2]);
  1094.     if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) {
  1095.         return TCL_ERROR;
  1096.     }
  1097.     if ((*argv[4] == 'e')
  1098.         && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) {
  1099.         last = stringLength-1;
  1100.     } else {
  1101.         if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) {
  1102.         Tcl_ResetResult(interp);
  1103.         Tcl_AppendResult(interp,
  1104.             "expected integer or \"end\" but got \"",
  1105.             argv[4], "\"", (char *) NULL);
  1106.         return TCL_ERROR;
  1107.         }
  1108.     }
  1109.     if (first < 0) {
  1110.         first = 0;
  1111.     }
  1112.     if (last >= stringLength) {
  1113.         last = stringLength-1;
  1114.     }
  1115.     if (last >= first) {
  1116.         char saved, *p;
  1117.  
  1118.         p = argv[2] + last + 1;
  1119.         saved = *p;
  1120.         *p = 0;
  1121.         Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE);
  1122.         *p = saved;
  1123.     }
  1124.     return TCL_OK;
  1125.     } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0)
  1126.         && (length >= 3)) {
  1127.     register char *p;
  1128.  
  1129.     if (argc != 3) {
  1130.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1131.             " tolower string\"", (char *) NULL);
  1132.         return TCL_ERROR;
  1133.     }
  1134.     Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
  1135.     for (p = interp->result; *p != 0; p++) {
  1136.         if (isupper(UCHAR(*p))) {
  1137.         *p = tolower(*p);
  1138.         }
  1139.     }
  1140.     return TCL_OK;
  1141.     } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0)
  1142.         && (length >= 3)) {
  1143.     register char *p;
  1144.  
  1145.     if (argc != 3) {
  1146.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1147.             " toupper string\"", (char *) NULL);
  1148.         return TCL_ERROR;
  1149.     }
  1150.     Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
  1151.     for (p = interp->result; *p != 0; p++) {
  1152.         if (islower(UCHAR(*p))) {
  1153.         *p = toupper(*p);
  1154.         }
  1155.     }
  1156.     return TCL_OK;
  1157.     } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0)
  1158.         && (length == 4)) {
  1159.     char *trimChars;
  1160.     register char *p, *checkPtr;
  1161.  
  1162.     left = right = 1;
  1163.  
  1164.     trim:
  1165.     if (argc == 4) {
  1166.         trimChars = argv[3];
  1167.     } else if (argc == 3) {
  1168.         trimChars = " \t\n\r";
  1169.     } else {
  1170.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1171.             " ", argv[1], " string ?chars?\"", (char *) NULL);
  1172.         return TCL_ERROR;
  1173.     }
  1174.     p = argv[2];
  1175.     if (left) {
  1176.         for (c = *p; c != 0; p++, c = *p) {
  1177.         for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
  1178.             if (*checkPtr == 0) {
  1179.             goto doneLeft;
  1180.             }
  1181.         }
  1182.         }
  1183.     }
  1184.     doneLeft:
  1185.     Tcl_SetResult(interp, p, TCL_VOLATILE);
  1186.     if (right) {
  1187.         char *donePtr;
  1188.  
  1189.         p = interp->result + strlen(interp->result) - 1;
  1190.         donePtr = &interp->result[-1];
  1191.         for (c = *p; p != donePtr; p--, c = *p) {
  1192.         for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
  1193.             if (*checkPtr == 0) {
  1194.             goto doneRight;
  1195.             }
  1196.         }
  1197.         }
  1198.         doneRight:
  1199.         p[1] = 0;
  1200.     }
  1201.     return TCL_OK;
  1202.     } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0)
  1203.         && (length > 4)) {
  1204.     left = 1;
  1205.     argv[1] = "trimleft";
  1206.     goto trim;
  1207.     } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0)
  1208.         && (length > 4)) {
  1209.     right = 1;
  1210.     argv[1] = "trimright";
  1211.     goto trim;
  1212.     } else if ((c == 'w') && (strncmp(argv[1], "wordend", length) == 0)
  1213.         && (length > 4)) {
  1214.     int length, index, cur;
  1215.     char *string;
  1216.  
  1217.     if (argc != 4) {
  1218.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1219.             " ", argv[1], " string index\"", (char *) NULL);
  1220.         return TCL_ERROR;
  1221.     }
  1222.     string = argv[2];
  1223.     if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) {
  1224.         return TCL_ERROR;
  1225.     }
  1226.     length = strlen(argv[2]);
  1227.     if (index < 0) {
  1228.         index = 0;
  1229.     }
  1230.     if (index >= length) {
  1231.         cur = length;
  1232.         goto wordendDone;
  1233.     }
  1234.     for (cur = index ; cur < length; cur++) {
  1235.         c = UCHAR(string[cur]);
  1236.         if (!isalnum(c) && (c != '_')) {
  1237.         break;
  1238.         }
  1239.     }
  1240.     if (cur == index) {
  1241.         cur = index+1;
  1242.     }
  1243.     wordendDone:
  1244.     sprintf(interp->result, "%d", cur);
  1245.     return TCL_OK;
  1246.     } else if ((c == 'w') && (strncmp(argv[1], "wordstart", length) == 0)
  1247.         && (length > 4)) {
  1248.     int length, index, cur;
  1249.     char *string;
  1250.  
  1251.     if (argc != 4) {
  1252.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1253.             " ", argv[1], " string index\"", (char *) NULL);
  1254.         return TCL_ERROR;
  1255.     }
  1256.     string = argv[2];
  1257.     if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) {
  1258.         return TCL_ERROR;
  1259.     }
  1260.     length = strlen(argv[2]);
  1261.     if (index >= length) {
  1262.         index = length-1;
  1263.     }
  1264.     if (index <= 0) {
  1265.         cur = 0;
  1266.         goto wordstartDone;
  1267.     }
  1268.     for (cur = index ; cur >= 0; cur--) {
  1269.         c = UCHAR(string[cur]);
  1270.         if (!isalnum(c) && (c != '_')) {
  1271.         break;
  1272.         }
  1273.     }
  1274.     if (cur != index) {
  1275.         cur += 1;
  1276.     }
  1277.     wordstartDone:
  1278.     sprintf(interp->result, "%d", cur);
  1279.     return TCL_OK;
  1280.     } else {
  1281.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1282.         "\": should be compare, first, index, last, length, match, ",
  1283.         "range, tolower, toupper, trim, trimleft, trimright, ",
  1284.         "wordend, or wordstart", (char *) NULL);
  1285.     return TCL_ERROR;
  1286.     }
  1287. }
  1288.  
  1289. /*
  1290.  *----------------------------------------------------------------------
  1291.  *
  1292.  * Tcl_SubstCmd --
  1293.  *
  1294.  *    This procedure is invoked to process the "subst" Tcl command.
  1295.  *    See the user documentation for details on what it does.  This
  1296.  *    command is an almost direct copy of an implementation by
  1297.  *    Andrew Payne.
  1298.  *
  1299.  * Results:
  1300.  *    A standard Tcl result.
  1301.  *
  1302.  * Side effects:
  1303.  *    See the user documentation.
  1304.  *
  1305.  *----------------------------------------------------------------------
  1306.  */
  1307.  
  1308.     /* ARGSUSED */
  1309. int
  1310. Tcl_SubstCmd(dummy, interp, argc, argv)
  1311.     ClientData dummy;            /* Not used. */
  1312.     Tcl_Interp *interp;            /* Current interpreter. */
  1313.     int argc;                /* Number of arguments. */
  1314.     char **argv;            /* Argument strings. */
  1315. {
  1316.     Interp *iPtr = (Interp *) interp;
  1317.     Tcl_DString result;
  1318.     char *p, *old, *value;
  1319.     int code, count, doVars, doCmds, doBackslashes, i;
  1320.     size_t length;
  1321.     char c;
  1322.  
  1323.     /*
  1324.      * Parse command-line options.
  1325.      */
  1326.  
  1327.     doVars = doCmds = doBackslashes = 1;
  1328.     for (i = 1; i < (argc-1); i++) {
  1329.     p = argv[i];
  1330.     if (*p != '-') {
  1331.         break;
  1332.     }
  1333.     length = strlen(p);
  1334.     if (length < 4) {
  1335.         badSwitch:
  1336.         Tcl_AppendResult(interp, "bad switch \"", p,
  1337.             "\": must be -nobackslashes, -nocommands, ",
  1338.             "or -novariables", (char *) NULL);
  1339.         return TCL_ERROR;
  1340.     }
  1341.     if ((p[3] == 'b') && (strncmp(p, "-nobackslashes", length) == 0)) {
  1342.         doBackslashes = 0;
  1343.     } else if ((p[3] == 'c') && (strncmp(p, "-nocommands", length) == 0)) {
  1344.         doCmds = 0;
  1345.     } else if ((p[3] == 'v') && (strncmp(p, "-novariables", length) == 0)) {
  1346.         doVars = 0;
  1347.     } else {
  1348.         goto badSwitch;
  1349.     }
  1350.     }
  1351.     if (i != (argc-1)) {
  1352.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1353.         " ?-nobackslashes? ?-nocommands? ?-novariables? string\"",
  1354.         (char *) NULL);
  1355.     return TCL_ERROR;
  1356.     }
  1357.  
  1358.     /*
  1359.      * Scan through the string one character at a time, performing
  1360.      * command, variable, and backslash substitutions.
  1361.      */
  1362.  
  1363.     Tcl_DStringInit(&result);
  1364.     old = p = argv[i];
  1365.     while (*p != 0) {
  1366.     switch (*p) {
  1367.         case '\\':
  1368.         if (doBackslashes) {
  1369.             if (p != old) {
  1370.             Tcl_DStringAppend(&result, old, p-old);
  1371.             }
  1372.             c = Tcl_Backslash(p, &count);
  1373.             Tcl_DStringAppend(&result, &c, 1);
  1374.             p += count;
  1375.             old = p;
  1376.         } else {
  1377.             p++;
  1378.         }
  1379.         break;
  1380.  
  1381.         case '$':
  1382.         if (doVars) {
  1383.             if (p != old) {
  1384.             Tcl_DStringAppend(&result, old, p-old);
  1385.             }
  1386.             value = Tcl_ParseVar(interp, p, &p);
  1387.             if (value == NULL) {
  1388.             Tcl_DStringFree(&result);
  1389.             return TCL_ERROR;
  1390.             }
  1391.             Tcl_DStringAppend(&result, value, -1);
  1392.             old = p;
  1393.         } else {
  1394.             p++;
  1395.         }
  1396.         break;
  1397.  
  1398.         case '[':
  1399.         if (doCmds) {
  1400.             if (p != old) {
  1401.             Tcl_DStringAppend(&result, old, p-old);
  1402.             }
  1403.             iPtr->evalFlags = TCL_BRACKET_TERM;
  1404.             code = Tcl_Eval(interp, p+1);
  1405.             if (code == TCL_ERROR) {
  1406.             Tcl_DStringFree(&result);
  1407.             return code;
  1408.             }
  1409.             old = p = iPtr->termPtr+1;
  1410.             Tcl_DStringAppend(&result, iPtr->result, -1);
  1411.             Tcl_ResetResult(interp);
  1412.         } else {
  1413.             p++;
  1414.         }
  1415.         break;
  1416.  
  1417.         default:
  1418.         p++;
  1419.         break;
  1420.     }
  1421.     }
  1422.     if (p != old) {
  1423.     Tcl_DStringAppend(&result, old, p-old);
  1424.     }
  1425.     Tcl_DStringResult(interp, &result);
  1426.     return TCL_OK;
  1427. }
  1428.  
  1429. /*
  1430.  *----------------------------------------------------------------------
  1431.  *
  1432.  * Tcl_SwitchCmd --
  1433.  *
  1434.  *    This procedure is invoked to process the "switch" Tcl command.
  1435.  *    See the user documentation for details on what it does.
  1436.  *
  1437.  * Results:
  1438.  *    A standard Tcl result.
  1439.  *
  1440.  * Side effects:
  1441.  *    See the user documentation.
  1442.  *
  1443.  *----------------------------------------------------------------------
  1444.  */
  1445.  
  1446.     /* ARGSUSED */
  1447. int
  1448. Tcl_SwitchCmd(dummy, interp, argc, argv)
  1449.     ClientData dummy;            /* Not used. */
  1450.     Tcl_Interp *interp;            /* Current interpreter. */
  1451.     int argc;                /* Number of arguments. */
  1452.     char **argv;            /* Argument strings. */
  1453. {
  1454. #define EXACT    0
  1455. #define GLOB    1
  1456. #define REGEXP    2
  1457.     int i, code, mode, matched;
  1458.     int body;
  1459.     char *string;
  1460.     int switchArgc, splitArgs;
  1461.     char **switchArgv;
  1462.  
  1463.     switchArgc = argc-1;
  1464.     switchArgv = argv+1;
  1465.     mode = EXACT;
  1466.     while ((switchArgc > 0) && (*switchArgv[0] == '-')) {
  1467.     if (strcmp(*switchArgv, "-exact") == 0) {
  1468.         mode = EXACT;
  1469.     } else if (strcmp(*switchArgv, "-glob") == 0) {
  1470.         mode = GLOB;
  1471.     } else if (strcmp(*switchArgv, "-regexp") == 0) {
  1472.         mode = REGEXP;
  1473.     } else if (strcmp(*switchArgv, "--") == 0) {
  1474.         switchArgc--;
  1475.         switchArgv++;
  1476.         break;
  1477.     } else {
  1478.         Tcl_AppendResult(interp, "bad option \"", switchArgv[0],
  1479.             "\": should be -exact, -glob, -regexp, or --",
  1480.             (char *) NULL);
  1481.         return TCL_ERROR;
  1482.     }
  1483.     switchArgc--;
  1484.     switchArgv++;
  1485.     }
  1486.     if (switchArgc < 2) {
  1487.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1488.         argv[0], " ?switches? string pattern body ... ?default body?\"",
  1489.         (char *) NULL);
  1490.     return TCL_ERROR;
  1491.     }
  1492.     string = *switchArgv;
  1493.     switchArgc--;
  1494.     switchArgv++;
  1495.  
  1496.     /*
  1497.      * If all of the pattern/command pairs are lumped into a single
  1498.      * argument, split them out again.
  1499.      */
  1500.  
  1501.     splitArgs = 0;
  1502.     if (switchArgc == 1) {
  1503.     code = Tcl_SplitList(interp, switchArgv[0], &switchArgc, &switchArgv);
  1504.     if (code != TCL_OK) {
  1505.         return code;
  1506.     }
  1507.     splitArgs = 1;
  1508.     }
  1509.  
  1510.     for (i = 0; i < switchArgc; i += 2) {
  1511.     if (i == (switchArgc-1)) {
  1512.         interp->result = "extra switch pattern with no body";
  1513.         code = TCL_ERROR;
  1514.         goto cleanup;
  1515.     }
  1516.  
  1517.     /*
  1518.      * See if the pattern matches the string.
  1519.      */
  1520.  
  1521.     matched = 0;
  1522.     if ((*switchArgv[i] == 'd') && (i == switchArgc-2)
  1523.         && (strcmp(switchArgv[i], "default") == 0)) {
  1524.         matched = 1;
  1525.     } else {
  1526.         switch (mode) {
  1527.         case EXACT:
  1528.             matched = (strcmp(string, switchArgv[i]) == 0);
  1529.             break;
  1530.         case GLOB:
  1531.             matched = Tcl_StringMatch(string, switchArgv[i]);
  1532.             break;
  1533.         case REGEXP:
  1534.             matched = Tcl_RegExpMatch(interp, string, switchArgv[i]);
  1535.             if (matched < 0) {
  1536.             code = TCL_ERROR;
  1537.             goto cleanup;
  1538.             }
  1539.             break;
  1540.         }
  1541.     }
  1542.     if (!matched) {
  1543.         continue;
  1544.     }
  1545.  
  1546.     /*
  1547.      * We've got a match.  Find a body to execute, skipping bodies
  1548.      * that are "-".
  1549.      */
  1550.  
  1551.     for (body = i+1; ; body += 2) {
  1552.         if (body >= switchArgc) {
  1553.         Tcl_AppendResult(interp, "no body specified for pattern \"",
  1554.             switchArgv[i], "\"", (char *) NULL);
  1555.         code = TCL_ERROR;
  1556.         goto cleanup;
  1557.         }
  1558.         if ((switchArgv[body][0] != '-') || (switchArgv[body][1] != 0)) {
  1559.         break;
  1560.         }
  1561.     }
  1562.     code = Tcl_Eval(interp, switchArgv[body]);
  1563.     if (code == TCL_ERROR) {
  1564.         char msg[100];
  1565.         sprintf(msg, "\n    (\"%.50s\" arm line %d)", switchArgv[i],
  1566.             interp->errorLine);
  1567.         Tcl_AddErrorInfo(interp, msg);
  1568.     }
  1569.     goto cleanup;
  1570.     }
  1571.  
  1572.     /*
  1573.      * Nothing matched:  return nothing.
  1574.      */
  1575.  
  1576.     code = TCL_OK;
  1577.  
  1578.     cleanup:
  1579.     if (splitArgs) {
  1580.     ckfree((char *) switchArgv);
  1581.     }
  1582.     return code;
  1583. }
  1584.  
  1585. /*
  1586.  *----------------------------------------------------------------------
  1587.  *
  1588.  * Tcl_TraceCmd --
  1589.  *
  1590.  *    This procedure is invoked to process the "trace" Tcl command.
  1591.  *    See the user documentation for details on what it does.
  1592.  *
  1593.  * Results:
  1594.  *    A standard Tcl result.
  1595.  *
  1596.  * Side effects:
  1597.  *    See the user documentation.
  1598.  *
  1599.  *----------------------------------------------------------------------
  1600.  */
  1601.  
  1602.     /* ARGSUSED */
  1603. int
  1604. Tcl_TraceCmd(dummy, interp, argc, argv)
  1605.     ClientData dummy;            /* Not used. */
  1606.     Tcl_Interp *interp;            /* Current interpreter. */
  1607.     int argc;                /* Number of arguments. */
  1608.     char **argv;            /* Argument strings. */
  1609. {
  1610.     int c;
  1611.     size_t length;
  1612.  
  1613.     if (argc < 2) {
  1614.     Tcl_AppendResult(interp, "too few args: should be \"",
  1615.         argv[0], " option [arg arg ...]\"", (char *) NULL);
  1616.     return TCL_ERROR;
  1617.     }
  1618.     c = argv[1][1];
  1619.     length = strlen(argv[1]);
  1620.     if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0)
  1621.         && (length >= 2)) {
  1622.     char *p;
  1623.     int flags, length;
  1624.     TraceVarInfo *tvarPtr;
  1625.  
  1626.     if (argc != 5) {
  1627.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1628.             argv[0], " variable name ops command\"", (char *) NULL);
  1629.         return TCL_ERROR;
  1630.     }
  1631.  
  1632.     flags = 0;
  1633.     for (p = argv[3] ; *p != 0; p++) {
  1634.         if (*p == 'r') {
  1635.         flags |= TCL_TRACE_READS;
  1636.         } else if (*p == 'w') {
  1637.         flags |= TCL_TRACE_WRITES;
  1638.         } else if (*p == 'u') {
  1639.         flags |= TCL_TRACE_UNSETS;
  1640.         } else {
  1641.         goto badOps;
  1642.         }
  1643.     }
  1644.     if (flags == 0) {
  1645.         goto badOps;
  1646.     }
  1647.  
  1648.     length = strlen(argv[4]);
  1649.     tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
  1650.         (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1));
  1651.     tvarPtr->flags = flags;
  1652.     tvarPtr->errMsg = NULL;
  1653.     tvarPtr->length = length;
  1654.     flags |= TCL_TRACE_UNSETS;
  1655.     strcpy(tvarPtr->command, argv[4]);
  1656.     if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc,
  1657.         (ClientData) tvarPtr) != TCL_OK) {
  1658.         ckfree((char *) tvarPtr);
  1659.         return TCL_ERROR;
  1660.     }
  1661.     } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length)
  1662.         && (length >= 2)) == 0) {
  1663.     char *p;
  1664.     int flags, length;
  1665.     TraceVarInfo *tvarPtr;
  1666.     ClientData clientData;
  1667.  
  1668.     if (argc != 5) {
  1669.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1670.             argv[0], " vdelete name ops command\"", (char *) NULL);
  1671.         return TCL_ERROR;
  1672.     }
  1673.  
  1674.     flags = 0;
  1675.     for (p = argv[3] ; *p != 0; p++) {
  1676.         if (*p == 'r') {
  1677.         flags |= TCL_TRACE_READS;
  1678.         } else if (*p == 'w') {
  1679.         flags |= TCL_TRACE_WRITES;
  1680.         } else if (*p == 'u') {
  1681.         flags |= TCL_TRACE_UNSETS;
  1682.         } else {
  1683.         goto badOps;
  1684.         }
  1685.     }
  1686.     if (flags == 0) {
  1687.         goto badOps;
  1688.     }
  1689.  
  1690.     /*
  1691.      * Search through all of our traces on this variable to
  1692.      * see if there's one with the given command.  If so, then
  1693.      * delete the first one that matches.
  1694.      */
  1695.  
  1696.     length = strlen(argv[4]);
  1697.     clientData = 0;
  1698.     while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
  1699.         TraceVarProc, clientData)) != 0) {
  1700.         tvarPtr = (TraceVarInfo *) clientData;
  1701.         if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
  1702.             && (strncmp(argv[4], tvarPtr->command,
  1703.             (size_t) length) == 0)) {
  1704.         Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,
  1705.             TraceVarProc, clientData);
  1706.         if (tvarPtr->errMsg != NULL) {
  1707.             ckfree(tvarPtr->errMsg);
  1708.         }
  1709.         ckfree((char *) tvarPtr);
  1710.         break;
  1711.         }
  1712.     }
  1713.     } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0)
  1714.         && (length >= 2)) {
  1715.     ClientData clientData;
  1716.     char ops[4], *p;
  1717.     char *prefix = "{";
  1718.  
  1719.     if (argc != 3) {
  1720.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1721.             argv[0], " vinfo name\"", (char *) NULL);
  1722.         return TCL_ERROR;
  1723.     }
  1724.     clientData = 0;
  1725.     while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
  1726.         TraceVarProc, clientData)) != 0) {
  1727.         TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
  1728.         p = ops;
  1729.         if (tvarPtr->flags & TCL_TRACE_READS) {
  1730.         *p = 'r';
  1731.         p++;
  1732.         }
  1733.         if (tvarPtr->flags & TCL_TRACE_WRITES) {
  1734.         *p = 'w';
  1735.         p++;
  1736.         }
  1737.         if (tvarPtr->flags & TCL_TRACE_UNSETS) {
  1738.         *p = 'u';
  1739.         p++;
  1740.         }
  1741.         *p = '\0';
  1742.         Tcl_AppendResult(interp, prefix, (char *) NULL);
  1743.         Tcl_AppendElement(interp, ops);
  1744.         Tcl_AppendElement(interp, tvarPtr->command);
  1745.         Tcl_AppendResult(interp, "}", (char *) NULL);
  1746.         prefix = " {";
  1747.     }
  1748.     } else {
  1749.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1750.         "\": should be variable, vdelete, or vinfo",
  1751.         (char *) NULL);
  1752.     return TCL_ERROR;
  1753.     }
  1754.     return TCL_OK;
  1755.  
  1756.     badOps:
  1757.     Tcl_AppendResult(interp, "bad operations \"", argv[3],
  1758.         "\": should be one or more of rwu", (char *) NULL);
  1759.     return TCL_ERROR;
  1760. }
  1761.  
  1762. /*
  1763.  *----------------------------------------------------------------------
  1764.  *
  1765.  * TraceVarProc --
  1766.  *
  1767.  *    This procedure is called to handle variable accesses that have
  1768.  *    been traced using the "trace" command.
  1769.  *
  1770.  * Results:
  1771.  *    Normally returns NULL.  If the trace command returns an error,
  1772.  *    then this procedure returns an error string.
  1773.  *
  1774.  * Side effects:
  1775.  *    Depends on the command associated with the trace.
  1776.  *
  1777.  *----------------------------------------------------------------------
  1778.  */
  1779.  
  1780.     /* ARGSUSED */
  1781. static char *
  1782. TraceVarProc(clientData, interp, name1, name2, flags)
  1783.     ClientData clientData;    /* Information about the variable trace. */
  1784.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1785.     char *name1;        /* Name of variable or array. */
  1786.     char *name2;        /* Name of element within array;  NULL means
  1787.                  * scalar variable is being referenced. */
  1788.     int flags;            /* OR-ed bits giving operation and other
  1789.                  * information. */
  1790. {
  1791.     TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
  1792.     char *result;
  1793.     int code;
  1794.     Interp dummy;
  1795.     Tcl_DString cmd;
  1796.  
  1797.     result = NULL;
  1798.     if (tvarPtr->errMsg != NULL) {
  1799.     ckfree(tvarPtr->errMsg);
  1800.     tvarPtr->errMsg = NULL;
  1801.     }
  1802.     if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
  1803.  
  1804.     /*
  1805.      * Generate a command to execute by appending list elements
  1806.      * for the two variable names and the operation.  The five
  1807.      * extra characters are for three space, the opcode character,
  1808.      * and the terminating null.
  1809.      */
  1810.  
  1811.     if (name2 == NULL) {
  1812.         name2 = "";
  1813.     }
  1814.     Tcl_DStringInit(&cmd);
  1815.     Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length);
  1816.     Tcl_DStringAppendElement(&cmd, name1);
  1817.     Tcl_DStringAppendElement(&cmd, name2);
  1818.     if (flags & TCL_TRACE_READS) {
  1819.         Tcl_DStringAppend(&cmd, " r", 2);
  1820.     } else if (flags & TCL_TRACE_WRITES) {
  1821.         Tcl_DStringAppend(&cmd, " w", 2);
  1822.     } else if (flags & TCL_TRACE_UNSETS) {
  1823.         Tcl_DStringAppend(&cmd, " u", 2);
  1824.     }
  1825.  
  1826.     /*
  1827.      * Execute the command.  Be careful to save and restore the
  1828.      * result from the interpreter used for the command.
  1829.      */
  1830.  
  1831.     if (interp->freeProc == 0) {
  1832.         dummy.freeProc = (Tcl_FreeProc *) 0;
  1833.         dummy.result = "";
  1834.         Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE);
  1835.     } else {
  1836.         dummy.freeProc = interp->freeProc;
  1837.         dummy.result = interp->result;
  1838.         interp->freeProc = (Tcl_FreeProc *) 0;
  1839.     }
  1840.     code = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
  1841.     Tcl_DStringFree(&cmd);
  1842.     if (code != TCL_OK) {
  1843.         tvarPtr->errMsg = ckalloc((unsigned) (strlen(interp->result) + 1));
  1844.         strcpy(tvarPtr->errMsg, interp->result);
  1845.         result = tvarPtr->errMsg;
  1846.         Tcl_ResetResult(interp);        /* Must clear error state. */
  1847.     }
  1848.     Tcl_SetResult(interp, dummy.result,
  1849.         (dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc);
  1850.     }
  1851.     if (flags & TCL_TRACE_DESTROYED) {
  1852.     result = NULL;
  1853.     if (tvarPtr->errMsg != NULL) {
  1854.         ckfree(tvarPtr->errMsg);
  1855.     }
  1856.     ckfree((char *) tvarPtr);
  1857.     }
  1858.     return result;
  1859. }
  1860.  
  1861. /*
  1862.  *----------------------------------------------------------------------
  1863.  *
  1864.  * Tcl_WhileCmd --
  1865.  *
  1866.  *    This procedure is invoked to process the "while" Tcl command.
  1867.  *    See the user documentation for details on what it does.
  1868.  *
  1869.  * Results:
  1870.  *    A standard Tcl result.
  1871.  *
  1872.  * Side effects:
  1873.  *    See the user documentation.
  1874.  *
  1875.  *----------------------------------------------------------------------
  1876.  */
  1877.  
  1878.     /* ARGSUSED */
  1879. int
  1880. Tcl_WhileCmd(dummy, interp, argc, argv)
  1881.     ClientData dummy;            /* Not used. */
  1882.     Tcl_Interp *interp;            /* Current interpreter. */
  1883.     int argc;                /* Number of arguments. */
  1884.     char **argv;            /* Argument strings. */
  1885. {
  1886.     int result, value;
  1887.  
  1888.     if (argc != 3) {
  1889.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1890.         argv[0], " test command\"", (char *) NULL);
  1891.     return TCL_ERROR;
  1892.     }
  1893.  
  1894.     while (1) {
  1895.     result = Tcl_ExprBoolean(interp, argv[1], &value);
  1896.     if (result != TCL_OK) {
  1897.         return result;
  1898.     }
  1899.     if (!value) {
  1900.         break;
  1901.     }
  1902.     result = Tcl_Eval(interp, argv[2]);
  1903.     if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
  1904.         if (result == TCL_ERROR) {
  1905.         char msg[60];
  1906.         sprintf(msg, "\n    (\"while\" body line %d)",
  1907.             interp->errorLine);
  1908.         Tcl_AddErrorInfo(interp, msg);
  1909.         }
  1910.         break;
  1911.     }
  1912.     }
  1913.     if (result == TCL_BREAK) {
  1914.     result = TCL_OK;
  1915.     }
  1916.     if (result == TCL_OK) {
  1917.     Tcl_ResetResult(interp);
  1918.     }
  1919.     return result;
  1920. }
  1921.